home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / graphics.swg / 0095_Loading PCX Files.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-02-03  |  3.0 KB  |  102 lines
  1. {
  2.  
  3.  SL> Does someone has a pascalsource for showing a PCX file with a resolution
  4.  SL> of 640x400x256 /or a automatic build-in convertor who wil let the drawing
  5.  
  6. Sure thing, the following code will load PCX files with 256 colors and variable
  7. height and width (it looks into the header):  (Sorry about the german comments,
  8. but I've got no time to erase them right now :-(( ) }
  9.  
  10. UNIT uVESAPcx;                                { (c) 1993 by NEBULA-Software }
  11.      { PCX-Darstellungsroutinen f. VESA     } { Olaf Bartelt & Oliver Carow }
  12.  
  13. INTERFACE                                     { Interface-Teil der Unit     }
  14.  
  15. { ───────────────────────────────── Typen ───────────────────────────────── }
  16. TYPE  pVESAPcx   = ^tVESAPcx;                 { Zeiger auf Objekt           }
  17.       tVESAPcx   = OBJECT                     { Objekt für PCX-Dateien      }
  18.                      PROCEDURE load(f : STRING; dx, dy : WORD);
  19.                    END;
  20.  
  21. { ──────────────────────────────── Variablen ────────────────────────────── }
  22. VAR   vVESAPcx  : pVESAPcx;                   { Instanz des Objekts tPcx    }
  23.  
  24.  
  25. IMPLEMENTATION                                { Implementation-Teil d. Unit }
  26.  
  27. USES uVesa;                                   { Einbinden der Units         }
  28. { CAN BE FOUND IN SWAG }
  29.  
  30. { ──────────────────────────────── tVESAPcx ─────────────────────────────── }
  31. PROCEDURE  tVESAPcx.load(f : STRING; dx, dy : WORD);
  32. VAR q                          : FILE;
  33.     b                          : ARRAY[0..2047] OF BYTE;
  34.     anz, pos, c, w, h, e, pack : WORD;
  35.     x, y                       : WORD;
  36.  
  37. LABEL ende_background;
  38.  
  39. BEGIN
  40.   x := 0; y := 0;
  41.  
  42.   ASSIGN(q, f); {$I-} RESET(q, 1); {$I+}
  43.   IF IORESULT <> 0 THEN
  44.     GOTO ende_background;
  45.  
  46.   BLOCKREAD(q, b, 128, anz);
  47.   IF (b[0] <> 10) OR (b[3] <> 8) THEN
  48.   BEGIN
  49.     CLOSE(q);
  50.     EXIT;
  51.   END;
  52.   w := SUCC((b[9] - b[5]) SHL 8 + b[8] - b[4]);
  53.   h := SUCC((b[11] - b[7]) SHL 8 + b[10] - b[6]);
  54.   pack := 0; c := 0; e := y + h;
  55.   REPEAT
  56.     BLOCKREAD(q, b, 2048, anz);
  57.     pos := 0;
  58.     WHILE (pos < anz) AND (y < e) DO
  59.     BEGIN
  60.       IF pack <> 0 THEN
  61.       BEGIN
  62.         FOR c := c TO c + pack DO
  63.           vVesa^.putpixel(x + c+dx, y+dy, b[pos]);
  64.         pack := 0;
  65.       END
  66.       ELSE
  67.         IF (b[pos] AND $C0) = $C0 THEN
  68.           pack := b[pos] AND $3F
  69.         ELSE
  70.         BEGIN
  71.           vVesa^.putpixel(x + c+dx, y+dy, b[pos]);
  72.           INC(c);
  73.         END;
  74.       INC(pos);
  75.       IF c = w THEN
  76.       BEGIN
  77.         c := 0;
  78.         INC(y);
  79.       END;
  80.     END;
  81.   UNTIL (anz = 0) OR (y = e);
  82.   SEEK(q, FILESIZE(q) - 3 SHL 8 - 1);
  83.   BLOCKREAD(q, b, 3 SHL 8 + 1);
  84.   IF b[0] = 12 THEN
  85.     FOR x := 1 TO 3 SHL 8 + 1 DO
  86.       b[x] := b[x] SHR 2;
  87.   CLOSE(q);
  88.  
  89.   ende_background:
  90. END;
  91.  
  92.  
  93. { ────────────────────────────── Hauptprogramm ──────────────────────────── }
  94. BEGIN
  95.   NEW(vVESAPcx);
  96. END.
  97.  
  98. Remember to put in *your* putpixel routines there!
  99.  
  100. scroll from top till bottom.(VGA/SVGAcompat./TPASCAL6.0)
  101.  
  102.